home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
HamCall (October 1991)
/
HamCall (Whitehall Publishing)(1991).bin
/
prgming
/
ada
/
sortarry.ada
< prev
next >
Wrap
Text File
|
1987-10-19
|
62KB
|
1,587 lines
-------- SIMTEL20 Ada Software Repository Prologue ------------
-- -*
-- Unit name : generic package Sort_Utilities
-- Version : 1.3 (FRAY297)
-- Author : Geoffrey O. Mendal
-- : Stanford University
-- : Computer Systems Laboratory, ERL 456
-- : Stanford, CA 94305
-- : (415) 723-1414 or 723-1175
-- DDN Address : Mendal@SIERRA.STANFORD.EDU
-- Copyright : (c) 1985, 1986, 1987 Geoffrey O. Mendal
-- Date created : Mon 11 Nov 85
-- Release date : Sun 25 Dec 85
-- Last update : MENDAL Fri 29 May 87
-- Machine/System Compiled/Run on : DG MV10000, ROLM ADE
-- VAX 11/780, DEC ACS
-- RATIONAL R1000
-- SEQUENT B21000, VERDIX VADS
-- SUN/3, VERDIX VADS
-- Dependent Units : package SYSTEM
-- -*
---------------------------------------------------------------
-- -*
-- Keywords : SORT
----------------: SORT UTILITIES
--
-- Abstract : This generic package contains several
----------------: array sorting routines.
-- -*
------------------ Revision history ---------------------------
-- -*
-- DATE VERSION AUTHOR HISTORY
-- 12/29/85 1.0 (MOOV115) Mendal Initial Release
-- 04/11/86 1.1 (FRPR116) Mendal ANNA formal comments
-- 12/07/86 1.2 (SUEC076) Mendal more ANNA annotations
-- 05/29/87 1.3 (FRAY297) Mendal annotation changes
-- -*
------------------ Distribution and Copyright -----------------
-- -*
-- This prologue must be included in all copies of this software.
--
-- This software is copyright by the author.
--
-- This software is released to the Ada community.
-- This software is released to the Public Domain (note:
-- software released to the Public Domain is not subject
-- to copyright protection).
-- Restrictions on use or distribution: NONE
-- -*
------------------ Disclaimer ---------------------------------
-- -*
-- This software and its documentation are provided "AS IS" and
-- without any expressed or implied warranties whatsoever.
-- No warranties as to performance, merchantability, or fitness
-- for a particular purpose exist.
--
-- Because of the diversity of conditions and hardware under
-- which this software may be used, no warranty of fitness for
-- a particular purpose is offered. The user is advised to
-- test the software thoroughly before relying on it. The user
-- must assume the entire risk and liability of using this
-- software.
--
-- In no event shall any person or organization of people be
-- held responsible for any direct, indirect, consequential
-- or inconsequential damages or lost profits.
-- -*
-------------------END-PROLOGUE--------------------------------
-- Sort_Utilities is a generic sorting package. The Sort subprograms
-- will sort a one dimensional array of any component type that supports
-- assignment, equality, and inequality (private types) indexed by
-- discrete type components. The default linear order is ascending order
-- but may be overridden by the user. The default sort algorithm,
-- Quicksort (non-recursive), may also be overridden.
-- Note that the component type can be a record type. The Sort subprograms
-- are not restricted to simple data types. If records are to be sorted,
-- then the formal generic subprogram parameter "<" must be
-- specified with by a linear order, e.g., a function provided
-- as an actual generic subprogram parameter at instantiation.
-- Note that the component type can be an access type (which can
-- point to other objects, improving sort efficiency). If access types
-- are to be sorted, then the formal generic subprogram parameter "<"
-- must be specified by a linear order (see example #3 below).
-- Since access types can be sorted, the Sort routine below can be
-- used to sort limited types and unconstrained types (designated by
-- an access type).
-- For data in which equality does not truly apply (i.e., real types)
-- one can use the Equal function to specify an equality operation.
-- Hence, one can decide that two numbers are "close enough" to be
-- equal (see example #4 below).
-- The number of comparisons and exchanges made to sort the array
-- can be returned. These numbers should give some indication on how
-- much work was actually performed by the sorting algorithms. These
-- numbers can also be used to compare the relative efficiency
-- of the sorting algorithms.
-- This package can be used to sort data on external devices. The user
-- should use this package to sort a subset of the external data, then
-- use a merge operation on all sorted subsets. For example, if the
-- system can only hold 1000 components in RAM, but you need to sort
-- 3000 components, bring in components #1-1000 and sort them using this
-- routine, and then write them to a file. Next do the same with
-- components #1001-2000, and finally with components #2001-3000. Now
-- merge the three sorted files using a merge package.
-- One of the Sort subprograms is a function which can be used to sort
-- an array and test it against another in an inline expression. This
-- can be useful when comparing the contents of two arrays which may be
-- equal, but not at the identical indices. This will be most useful for
-- comparing the equality of sets implemented as arrays (see example #5
-- below).
-- Other Sort subprograms allow the user to maintain the original state
-- of the array by returning a new array that is sorted. These subprograms
-- will be useful in cases where sorting is required, but the original
-- (unsorted) data must be preserved.
-- This package has been formally annotated using the ANNA specification
-- language. For more information, contact the author. Also, the
-- design of this package has been documented in the IEEE Computer
-- Society Second International Conference on Ada Applications and
-- Environments proceedings. Contact the IEEE or the author for a copy
-- of the paper. This paper is forthcoming in a special issue of IEEE
-- Software also.
with SYSTEM; -- predefined package SYSTEM
generic
type Component_Type is private; -- type of the data components
type Index_Type is (<>); -- type of array index
-- The following generic formal type is required due to Ada's
-- strong typing requirements. The SORT subprograms cannot handle
-- anonymous array types. This type will match any unconstrained
-- array type definition (so that array slices can be sorted
-- too -- see example #3 below).
type Array_Type is array (Index_Type range <>) of Component_Type;
-- The following formal subprogram parameter defaults to the
-- predefined "<" operator which will sort one-dimensional
-- arrays of Component_Type in ascending order (by default).
-- If composite or access types are to be sorted, a selector
-- function must be specified.
with function "<" (Left,Right : in Component_Type) return BOOLEAN is <>;
-- The following formal subprogram parameter defaults to the predefined
-- "=" operator. If user-defined equality is desired, one can write
-- an equality function and specify it here.
with function Equal (Left,Right : in Component_Type) return BOOLEAN is "=";
-- The annotations below formally specify assumptions about the
-- generic formals above that must be satisfied in order to perform
-- correct sorting.
--| for all X, Y, Z : Component_Type =>
--| (not (X < X)) and
--| (Equal (X, Y) xor (X < Y) xor (Y < X)) and
--| ((X < Y) and (Y < Z) -> (X < Z)) and
--| Equal (X, X) and
--| (Equal (X, Y) -> Equal (Y, X)) and
--| (Equal (X, Y) and Equal (Y, Z) -> Equal (X, Z)) and
--| (Equal (X, Y) and (X < Z) -> (Y < Z)) and
--| (Equal (X, Y) and (Z < X) -> (Z < Y));
package Sort_Utilities is
function Version return STRING; -- Returns the version number.
-- Users can specify the type of sorting algorithm they want by
-- specifying an enumeration literal from the type below. The default
-- algorithm, Quicksort (non-recursive), generally performs best.
-- One note about stability of the algorithms: only the Bubble Sorts
-- and Insertion Sort are stable algorithms. Thus, they are the
-- only algorithms that preserve the ordering of equal components
-- without use of a selector function. In all cases, a selector
-- function may be specified to introduce stability into the
-- sorting algorithms (see example #3 below).
type Sort_Algorithm_Type is (Quicksort, Recursive_Quicksort, Bsort,
Bubble_Sort, Bubble_Sort_with_Quick_Exit, Selection_Sort, Heapsort,
Insertion_Sort, Merge_Sort);
-- Quicksort: O(NlogN). Is most efficient when used with large, unsorted
-- arrays. Uses an explicit stack to maintain state and
-- partitions. Instable. This is the default algorithm.
-- Recursive_Quicksort: O(NlogN). Is most efficient when used with large,
-- unsorted arrays. Recursive nature may introduce significant
-- memory overhead for very large arrays. Instable.
-- Bsort: O(NlogN). Is most efficient when used with large arrays
-- that are already sorted, partially sorted, or sorted in
-- reverse. Recursive. Instable.
-- Bubble_Sort: O(N**2). Is most efficient when used with small
-- arrays that are almost already sorted. Non-recursive.
-- Brute force. Low memory requirements. Stable.
-- Bubble_Sort_with_Quick_Exit: O(N**2). Is most efficient when
-- used with small arrays that are almost already sorted.
-- Non-recursive. Same as bubble sort above except brute
-- force is limited. Stable.
-- Selection_Sort: O(N**2). Is most efficient when used with
-- small arrays in which the Component_Type is a
-- record type. Non-recursive. Brute force. Instable.
-- Heapsort: O(NlogN). Is most efficient when used with
-- large, unsorted arrays. Non-recursive. Very low
-- memory requirements. Instable.
-- Insertion_Sort: O(N**2). Is most efficient when used with
-- small arrays that are almost already sorted. Non-
-- recursive. Brute force. Stable.
-- Merge_Sort: O(NlogN). Is most efficient when used with medium-large
-- arrays. Non-recursive. Instable. Uses an auxiliary array
-- to perform merging.
-- The following type declaration should be used to specify the
-- instrumentation analysis results that can be returned by the Sort
-- subprograms below. -1 is only returned if an overflow in calculations
-- has occurred. The Sort subprograms will still sort the array if an
-- overflow in instrumentation analysis data calculations
-- occurs.
type Performance_Instrumentation_Type is range -1 .. SYSTEM.MAX_INT;
-- The following exception is raised during execution of the Sort
-- subprograms which take two arrays as parameters. These two arrays
-- must be of the same length.
Sort_Arrays_Length_Mismatch : exception;
-- The following virtual functions define the semantics of sorting.
-- The use of Index_Type'SUCC and Index_Type'PRED might raise
-- CONSTRAINT_ERROR on boundary limits, and need to be enhanced
-- in these cases. (An annotation that raises an exception during
-- its evaluation is not consistent with the specification.)
--: function Ordered (A : in Array_Type) return BOOLEAN;
--| where return (A'LENGTH <= 1) or else
--| (((A (A'FIRST) < A (Index_Type'SUCC (A'FIRST))) or
--| (Equal (A (A'FIRST), A (Index_Type'SUCC (A'FIRST))))) and
--| Ordered (A (Index_Type'SUCC (A'FIRST) .. A'LAST)));
--: function Permutation (A, B : in Array_Type) return BOOLEAN;
--| where A'LENGTH = B'LENGTH,
--| Ordered (B),
--| return (A'LENGTH = 0) or else
--| (exist I : B'RANGE =>
--| Equal (A (A'FIRST), B (I)) and
--| Permutation (A (Index_Type'SUCC (A'FIRST) .. A'LAST),
--| B (B'FIRST .. Index_Type'PRED (I)) &
--| B (Index_Type'SUCC (I) .. B'LAST)));
-- The following procedure will sort a one dimensional array of
-- components. It can sort in ascending/descending order or any
-- user-defined order. It can sort components of any type that
-- support equality, inequality, and assignment (private types).
-- The array indices can be of any discrete type. The number of
-- comparisons and exchanges can also be returned.
procedure Sort (
Sort_Array : in out Array_Type;
Number_of_Comparisons,
Number_of_Exchanges : out Performance_Instrumentation_Type;
Sort_Algorithm : in Sort_Algorithm_Type := Quicksort);
--| where out Ordered (Sort_Array),
--| out Permutation (in Sort_Array, Sort_Array),
--| out Number_of_Comparisons'DEFINED,
--| out Number_of_Exchanges'DEFINED,
--| raise Sort_Arrays_Length_Mismatch => FALSE;
-- The following overloading of procedure Sort should be specified
-- when no instrumentation analysis data are required.
procedure Sort (
Sort_Array : in out Array_Type;
Sort_Algorithm : in Sort_Algorithm_Type := Quicksort);
--| where out Ordered (Sort_Array),
--| out Permutation (in Sort_Array, Sort_Array),
--| raise Sort_Arrays_Length_Mismatch => FALSE;
-- The following overloading of procedure Sort should be used when
-- the original data must be preserved and instrumentation analysis
-- results are required.
procedure Sort (
Unsorted_Array : in Array_Type;
Sorted_Array : out Array_Type;
Number_of_Comparisons,
Number_of_Exchanges : out Performance_Instrumentation_Type;
Sort_Algorithm : in Sort_Algorithm_Type := Quicksort);
--| where out Ordered (Sorted_Array),
--| out Permutation (Unsorted_Array, Sorted_Array),
--| out Number_of_Comparisons'DEFINED,
--| out Number_of_Exchanges'DEFINED,
--| Unsorted_Array'LENGTH /= Sorted_Array'LENGTH =>
--| raise Sort_Arrays_Length_Mismatch;
-- The following overloading of procedure Sort should be used when
-- the original data must be preserved and no instrumentation analysis
-- results are required.
procedure Sort (
Unsorted_Array : in Array_Type;
Sorted_Array : out Array_Type;
Sort_Algorithm : in Sort_Algorithm_Type := Quicksort);
--| where out Ordered (Sorted_Array),
--| out Permutation (Unsorted_Array, Sorted_Array),
--| Unsorted_Array'LENGTH /= Sorted_Array'LENGTH =>
--| raise Sort_Arrays_Length_Mismatch;
-- The following overloading of function Sort should be used when
-- sorting is required in an inline expression.
function Sort (
Sort_Array : in Array_Type;
Sort_Algorithm : in Sort_Algorithm_Type := Quicksort)
return Array_Type;
--| where return A : Array_Type =>
--| Ordered (A) and Permutation (Sort_Array, A);
--| raise Sort_Arrays_Length_Mismatch => FALSE;
end Sort_Utilities;
-- Example uses/instantiations:
-- -- EXAMPLE #1: Sorting an array of CHARACTERs
-- with Sort_Utilities;
-- procedure Main is
-- type My_Index_Type is (Sun,Mon,Tue,Wed,Thu,Fri,Sat);
-- type My_Array_Type is array (My_Index_Type range <>) of CHARACTER;
-- package Ascending_Sort is new Sort_Utilities (
-- Component_Type => CHARACTER,
-- Index_Type => My_Index_Type,
-- Array_Type => My_Array_Type);
-- package Descending_Sort is new Sort_Utilities (
-- Component_Type => CHARACTER,
-- Index_Type => My_Index_Type,
-- Array_Type => My_Array_Type,
-- "<" => ">");
-- My_Array : My_Array_Type (Mon .. Fri);
-- Number_of_Comparisons,
-- Number_of_Exchanges, : Descending_Sort.Performance_Instrumentation_Type;
-- begin
-- Ascending_Sort.Sort (My_Array);
-- Descending_Sort.Sort (
-- Sort_Array => My_Array,
-- Number_of_Comparisons => Number_of_Comparisons,
-- Number_of_Exchanges => Number_of_Exchanges,
-- Sort_Algorithm => Descending_Sort.Bubble_Sort);
-- end Main;
-- -------------------------------------------------------------------
-- -- EXAMPLE #2: Sorting an array of records based on a key field
-- with Sort_Utilities;
-- procedure Main is
-- type My_Component_Type is
-- record
-- Field1 : INTEGER;
-- Field2 : FLOAT;
-- Field3 : CHARACTER;
-- end record;
-- subtype My_Index_Type is INTEGER range -10 .. 10;
-- type My_Array_Type is array (My_Index_Type range <>) of My_Component_Type;
-- My_Array : My_Array_Type (-10 .. 10);
-- function Ascending_Order_on_Field1 (Left,Right : in My_Component_Type) return BOOLEAN is
-- begin
-- return Left.Field1 < Right.Field1;
-- end Ascending_Order_on_Field1;
-- function Descending_Order_on_Field3 (Left,Right : in My_Component_Type) return BOOLEAN is
-- begin
-- return Left.Field3 > Right.Field3;
-- end Descending_Order_on_Field3;
-- package Ascending_Sort_on_Field1 is new Sort_Utilities (
-- Component_Type => My_Component_Type,
-- Index_Type => My_Index_Type,
-- Array_Type => My_Array_Type,
-- "<" => Ascending_Order_on_Field1);
-- package Descending_Sort_on_Field3 is new Sort_Utilities (
-- Component_Type => My_Component_Type,
-- Index_Type => My_Index_Type,
-- Array_Type => My_Array_Type,
-- "<" => Descending_Order_on_Field3);
-- Ascending_Sort_on_Field1.Sort (My_Array);
-- Descending_Sort_on_Field3.Sort (
-- Sort_Array => My_Array,
-- Sort_Algorithm => Descending_Sort_on_Field3.Selection_Sort);
-- end Main;
-- -------------------------------------------------------------------
-- EXAMPLE #3: Sorting an array slice of access types that designate
-- records.
-- with Sort_Utilities;
-- procedure Main is
-- type Taxpayer_Type is
-- record
-- Name : STRING (1 .. 40);
-- Age : NATURAL;
-- ID_Number : POSITIVE; -- social security number
-- end record;
-- type Taxpayer_Access_Type is access Taxpayer_Type;
-- type My_Index_Type is range 1 .. 1_000_000;
-- type My_Array_Type is array (My_Index_Type range <>) of Taxpayer_Access_Type;
-- My_Array : My_Array_Type (1 .. 1_000_000);
-- function Ascending_Taxpayers (Left,Right : in Taxpayer_Access_Type) return BOOLEAN is
-- begin
-- return (Left.Name < Right.Name) or
-- ((Left.Name = Right.Name) and (Left.ID_Number < Right.ID_Number));
-- end Ascending_Taxpayers;
-- package Ascending_Taxpayer_Sort is new Sort_Utilities (
-- Taxpayer_Access_Type,My_Index_Type,My_Array_Type,Ascending_Taxpayers);
-- Ascending_Taxpayer_Sort.Sort (My_Array(100..1_000));
-- end Main;
-- ---------------------------------------------------------------------------
-- EXAMPLE #4: Sorting an array of floating point numbers using a
-- constrained array subtype
-- with Sort_Utilities;
-- procedure Main is
-- type My_Array_Type is array (POSITIVE range <>) of FLOAT;
-- subtype My_Array_Subtype is My_Array_Type (1 .. 10);
-- My_Array : My_Array_Subtype;
-- function My_Equality (L, R : in FLOAT) is
-- begin
-- . . . -- check for "close enough" on equality
-- return <some BOOLEAN expression>;
-- end My_Equality;
-- package My_Sort_Utilities is new Sort_Utilities (FLOAT,POSITIVE,My_Array_Type,
-- My_Equality);
-- begin
-- My_Sort_Utilities.Sort (My_Array);
-- end Main;
-- ---------------------------------------------------------------------------
-- EXAMPLE #5: Sorting in an inline expression
-- with Sort_Utilities;
-- procedure Main is
-- type Set_Type is array (POSITIVE range <>) of CHARACTER;
-- Set1,
-- Set2 : Set_Type (1 .. 10);
-- package My_Sort_Utilities is new Sort_Utilities (CHARACTER,POSITIVE,Set_Type);
-- begin
-- if My_Sort_Utilities.Sort (Set1) = My_Sort_Utilities.Sort (Set2) then
-- . . .
-- end if;
-- end Main;
package body Sort_Utilities is
Version_Number : constant STRING := "1.3 (FRAY297)";
--: function Ordered (A : in Array_Type) return BOOLEAN is
--: begin
--: for I in A'FIRST .. Index_Type'PRED (A'LAST) loop
--: if A (Index_Type'SUCC (I)) < A (I) then
--: return FALSE;
--: end if;
--: end loop;
--: return TRUE;
--: end Ordered;
--: function Permutation (A, B : in Array_Type) return BOOLEAN is
--: type Mark_Array_Type is array (A'RANGE) of BOOLEAN;
--: Mark : Mark_Array_Type := (others => FALSE);
--: Mark_Pos : Index_Type;
--: Not_Marked : BOOLEAN;
--: begin
--: for I in A'RANGE loop
--: Not_Marked := TRUE;
--: for J in B'RANGE loop
--: if Equal (A (I), B (J)) and not Mark (J) then
--: Mark_Pos := J;
--: exit;
--: end if;
--: end loop;
--: if Not_Marked then
--: return FALSE;
--: else
--: Mark (Mark_Pos) := TRUE;
--: end if;
--: end loop;
--: return Mark = (others => TRUE);
--: end Permutation;
function Version return STRING is
begin
return Version_Number;
end Version;
-- The following subprograms are utilities for the sorting
-- procedures that follow them.
procedure Update_Performance_Instrumentation (
Instrumentation_Count : in out Performance_Instrumentation_Type) is
begin
-- Bump the counter unless an overflow has occurred.
if Instrumentation_Count /= Performance_Instrumentation_Type'FIRST then
if Instrumentation_Count /= Performance_Instrumentation_Type'LAST then
Instrumentation_Count := Instrumentation_Count + 1;
else
Instrumentation_Count := Performance_Instrumentation_Type'FIRST;
end if;
end if;
end Update_Performance_Instrumentation;
procedure Exchange_Array_Components (
Sort_Array : in out Array_Type;
Number_of_Exchanges : in out Performance_Instrumentation_Type) is
Temporary_Component : constant Component_Type :=
Sort_Array (Sort_Array'FIRST);
begin
Sort_Array (Sort_Array'FIRST) := Sort_Array (Sort_Array'LAST);
Sort_Array (Sort_Array'LAST) := Temporary_Component;
Update_Performance_Instrumentation (Number_of_Exchanges);
end Exchange_Array_Components;
-- Procedure Quicksort is the default sort algorithm used. It is
-- a non-recursive method of sorting by constantly partitioning the
-- array in half and sorting only that half. This algorithm is
-- O(NlogN) and is instable.
procedure Quicksort (
Sort_Array : in out Array_Type;
Number_of_Comparisons,
Number_of_Exchanges : out Performance_Instrumentation_Type) is
type Sort_Array_Index_Save_Type is
record
Left,
Right : Index_Type;
end record;
subtype Stack_Index_Type is NATURAL range 0 .. Sort_Array'LENGTH;
type Stack_Array_Type is array (Stack_Index_Type) of
Sort_Array_Index_Save_Type;
Local_Comparisons,
Local_Exchanges : Performance_Instrumentation_Type := 0;
I, J, L, R : Index_Type;
Temporary_Component : Component_Type;
Stack_Pointer : Stack_Index_Type;
Stack_Array : Stack_Array_Type;
begin
if Sort_Array'FIRST < Sort_Array'LAST then
Stack_Pointer := 1;
Stack_Array (1).Left := Sort_Array'FIRST;
Stack_Array (1).Right := Sort_Array'LAST;
loop -- Take top request from stack.
L := Stack_Array (Stack_Pointer).Left;
R := Stack_Array (Stack_Pointer).Right;
Stack_Pointer := Stack_Pointer - 1;
loop -- Split Sort_Array (Sort_Array'FIRST) .. Sort_Array (R).
I := L;
J := R;
Temporary_Component := Sort_Array (Index_Type'VAL (
((Index_Type'POS (L) + Index_Type'POS (R)) / 2)));
loop
loop
Update_Performance_Instrumentation (Local_Comparisons);
exit when (not (Sort_Array (I) < Temporary_Component)) or
(I = Sort_Array'LAST);
I := Index_Type'SUCC (I);
end loop;
loop
Update_Performance_Instrumentation (Local_Comparisons);
exit when (not (Temporary_Component < Sort_Array (J))) or
(J = Sort_Array'FIRST);
J := Index_Type'PRED (J);
end loop;
if I <= J then
if I /= J then
Exchange_Array_Components (Sort_Array (I .. J),Local_Exchanges);
end if;
if I /= Sort_Array'LAST then
I := Index_Type'SUCC (I);
end if;
if J /= Sort_Array'FIRST then
J := Index_Type'PRED (J);
end if;
end if;
exit when I > J;
end loop;
if (Index_Type'POS (J) - Index_Type'POS (L)) <
(Index_Type'POS (R) - Index_Type'POS (I)) then
if I < R then
-- Stack request for sorting right partition.
Stack_Pointer := Stack_Pointer + 1;
Stack_Array (Stack_Pointer).Left := I;
Stack_Array (Stack_Pointer).Right := R;
end if;
R := J; -- Continue sorting left partition.
else
if L < J then
-- Stack request for sorting left partition.
Stack_Pointer := Stack_Pointer + 1;
Stack_Array (Stack_Pointer).Left := L;
Stack_Array (Stack_Pointer).Right := J;
end if;
L := I; -- Continue sorting right partition.
end if;
exit when L >= R;
end loop;
exit when Stack_Pointer = 0;
end loop;
end if;
Number_of_Comparisons := Local_Comparisons;
Number_of_Exchanges := Local_Exchanges;
end Quicksort;
-- The following procedure houses a Quicksort that is identical to
-- the one above, except that recursion manages the state and paritions
-- instead of an explicit stack.
procedure Recursive_Quicksort (
Sort_Array : in out Array_Type;
Number_of_Comparisons,
Number_of_Exchanges : out Performance_Instrumentation_Type) is
Local_Comparisons,
Local_Exchanges : Performance_Instrumentation_Type := 0;
-- The recursive nature of the sorting algorithm is found in
-- the procedure below.
procedure Recursive_Quick (Sort_Array : in out Array_Type) is
I : Index_Type := Sort_Array'FIRST;
J : Index_Type := Sort_Array'LAST;
-- The partitioning of the array in half is found in the
-- procedure below. It is this procedure that really sorts
-- the array by making the necessary exchanges.
-- This algorithm DEPENDS on the fact that there are two or
-- more array components. Singleton or null arrays are special cases
-- and should be handled by the outermost level of the
-- Quicksort algorithm.
procedure Partition is
Sort_Array_Mid_Value : constant Component_Type :=
Sort_Array (Index_Type'VAL ((Index_Type'POS (I) + Index_Type'POS (J)) / 2));
begin
loop
while (Sort_Array (I) < Sort_Array_Mid_Value) and
(I /= Sort_Array'LAST) loop
Update_Performance_Instrumentation (Local_Comparisons);
I := Index_Type'SUCC (I);
end loop;
while (Sort_Array_Mid_Value < Sort_Array (J)) and
(J /= Sort_Array'FIRST) loop
Update_Performance_Instrumentation (Local_Comparisons);
J := Index_Type'PRED (J);
end loop;
if I <= J then
if I < J then
Exchange_Array_Components (Sort_Array (I .. J),Local_Exchanges);
end if;
if I /= Sort_Array'LAST then
I := Index_Type'SUCC (I);
end if;
if J /= Sort_Array'FIRST then
J := Index_Type'PRED (J);
end if;
end if;
exit when (I > J) or
((I = Sort_Array'LAST) and (J = Sort_Array'FIRST));
end loop;
end Partition;
begin -- Recursive_Quick
Partition;
if Sort_Array'FIRST < J then
Recursive_Quick (Sort_Array (Sort_Array'FIRST .. J));
end if;
if I < Sort_Array'LAST then
Recursive_Quick (Sort_Array (I .. Sort_Array'LAST));
end if;
end Recursive_Quick;
begin -- Recursive_Quicksort
-- Handle the special cases of singleton and null arrays...
-- do nothing.
if Sort_Array'FIRST < Sort_Array'LAST then
Recursive_Quick (Sort_Array);
end if;
Number_of_Comparisons := Local_Comparisons;
Number_of_Exchanges := Local_Exchanges;
end Recursive_Quicksort;
-- A variation on Recursive_Quicksort is found in the procedure below. It
-- is good for sorting data that is already ordered, partially ordered,
-- or reverse ordered. The algorithm is O(NlogN) and instable. It is
-- a combination of Recursive_Quicksort and Bubble_Sort_with_Quick_Exit.
procedure Bsort (
Sort_Array : in out Array_Type;
Number_of_Comparisons,
Number_of_Exchanges : out Performance_Instrumentation_Type) is
Local_Comparisons,
Local_Exchanges : Performance_Instrumentation_Type := 0;
-- The recursive nature of the algorithm is found in the procedure below.
procedure Recursive_Bsort (
Low_Index,
High_Index : in Index_Type;
Mid_Component : in Component_Type) is
Flag, Left_Flag, Right_Flag : BOOLEAN;
I, J : Index_Type;
Size : NATURAL;
-- Sort_Array (Low_Index .. High_Index) are the components to be
-- sorted, and Mid_Component is the value of the middle component.
-- I and J are used to partition the subfiles so that at any time
-- Sort_Array (I) < Mid_Component and (Mid_Component < Sort_Array (J)
-- or Mid_Component = Sort_Array (J)). Left_Flag is TRUE whenever
-- the left subfile is not in sorted order, and Right_Flag is
-- TRUE whenever the right subfile is not in sorted order. Flag is
-- FALSE when the partitioning processes are completed.
begin
if Low_Index < High_Index then
Left_Flag := FALSE;
Right_Flag := FALSE;
I := Low_Index;
J := High_Index;
Flag := TRUE;
while Flag loop
loop
Update_Performance_Instrumentation (Local_Comparisons);
exit when (Mid_Component < Sort_Array (I)) or
Equal (Mid_Component,Sort_Array (I)) or (I = J);
-- Build the left subfile ensuring that the rightmost component
-- is always the largest of the subfile.
if I /= Low_Index then
Update_Performance_Instrumentation (Local_Comparisons);
if Sort_Array (I) < Sort_Array (Index_Type'PRED (I)) then
Exchange_Array_Components (
Sort_Array (Index_Type'PRED (I) .. I),Local_Exchanges);
Left_Flag := TRUE;
end if;
end if;
I := Index_Type'SUCC (I);
end loop;
loop
Update_Performance_Instrumentation (Local_Comparisons);
exit when (Sort_Array (J) < Mid_Component) or (I = J);
-- Build the right subfile ensuring that the leftmost component
-- is always the smallest of the subfile.
if J /= High_Index then
Update_Performance_Instrumentation (Local_Comparisons);
if Sort_Array (Index_Type'SUCC (J)) < Sort_Array (J) then
Exchange_Array_Components (
Sort_Array (J .. Index_Type'SUCC (J)),Local_Exchanges);
Right_Flag := TRUE;
end if;
end if;
J := Index_Type'PRED (J);
end loop;
if I /= J then
-- Interchange Sort_Array (I) from the left subfile with
-- Sort_Array (J) from the right subfile.
Exchange_Array_Components (Sort_Array (I .. J),Local_Exchanges);
else -- I = J
-- Partitioning into left and right subfiles has been completed.
Update_Performance_Instrumentation (Local_Comparisons);
if (Mid_Component < Sort_Array (J)) or
Equal (Mid_Component,Sort_Array (J)) then
-- Check the right subfile to ensure the first component,
-- Sort_Array (J), is the smallest.
if J /= Sort_Array'LAST then
Update_Performance_Instrumentation (Local_Comparisons);
if Sort_Array (Index_Type'SUCC (J)) < Sort_Array (J) then
Exchange_Array_Components (
Sort_Array (J .. Index_Type'SUCC (J)),Local_Exchanges);
Right_Flag := TRUE;
end if;
end if;
else
-- Check the left subfile to ensure the last component,
-- Sort_Array (Index_Type'PRED (I)), is the largest.
if I /= Sort_Array'FIRST then
Update_Performance_Instrumentation (Local_Comparisons);
if Sort_Array (I) < Sort_Array (Index_Type'PRED (I)) then
Exchange_Array_Components (
Sort_Array (Index_Type'PRED (I) .. I),Local_Exchanges);
Left_Flag := TRUE;
end if;
end if;
if I > Index_Type'SUCC (Sort_Array'FIRST) then
Update_Performance_Instrumentation (Local_Comparisons);
if Sort_Array (Index_Type'PRED (I)) <
Sort_Array (Index_Type'PRED (Index_Type'PRED (I))) then
Exchange_Array_Components (
Sort_Array (Index_Type'PRED (Index_Type'PRED (I)) ..
Index_Type'PRED (I)),Local_Exchanges);
end if;
end if;
end if;
Flag := FALSE;
end if; -- end of "if I /= J"
end loop; -- end of "while Flag loop"
-- Process the left subfile.
Size := Index_Type'POS (I) - Index_Type'POS (Low_Index);
if Size > 2 then
-- Subfile must have at least three components to process and
-- not already sorted.
if Left_Flag then
if Size = 3 then
-- Special case of 3 components; place Sort_Array (Low_Index)
-- and Sort_Array (Index_Type'SUCC (Low_Index)) in sorted order.
Update_Performance_Instrumentation (Local_Comparisons);
if Sort_Array (Index_Type'SUCC (Low_Index)) <
Sort_Array (Low_Index) then
Exchange_Array_Components (
Sort_Array (Low_Index .. Index_Type'SUCC (Low_Index)),
Local_Exchanges);
end if;
else
Recursive_Bsort (Low_Index,Index_Type'PRED (Index_Type'PRED (I)),
Sort_Array (Index_Type'VAL (
((Index_Type'POS (Low_Index) + Index_Type'POS (I)
- 2) / 2)
)));
end if;
end if;
end if;
-- Process the right subfile.
Size := Index_Type'POS (High_Index) - Index_Type'POS (J) + 1;
if Size > 2 then
-- Subfile must have at least 3 components to process and not
-- already sorted.
if Right_Flag then
if Size = 3 then
-- Special case of 3 components; place
-- Sort_Array (Index_Type'SUCC (J)) and
-- Sort_Array (Index_Type'SUCC (Index_Type'SUCC (J))) in sorted
-- order.
Update_Performance_Instrumentation (Local_Comparisons);
if Sort_Array (Index_Type'SUCC (Index_Type'SUCC (J))) <
Sort_Array (Index_Type'SUCC (J)) then
Exchange_Array_Components (
Sort_Array (Index_Type'SUCC (J) ..
Index_Type'SUCC (Index_Type'SUCC (J))),
Local_Exchanges);
end if;
else
Recursive_Bsort (Index_Type'SUCC (J),High_Index,
Sort_Array (Index_Type'VAL (
((Index_Type'POS (J) + Index_Type'POS (High_Index)
+ 1) / 2)
)));
end if;
end if;
end if;
end if; -- end of "if M < N then"
end Recursive_Bsort;
begin -- Bsort
-- Do not bother with singleton and null arrays.
if Sort_Array'FIRST < Sort_Array'LAST then
Recursive_Bsort (Sort_Array'FIRST,Sort_Array'LAST,
Sort_Array (Index_Type'VAL (
((Index_Type'POS (Sort_Array'FIRST) +
Index_Type'POS (Sort_Array'LAST)) / 2))));
end if;
Number_of_Comparisons := Local_Comparisons;
Number_of_Exchanges := Local_Exchanges;
end Bsort;
-- A bubble sort algorithm is found in the procedure below. The
-- algorithm used is a standard bubble sort. This algorithm is
-- O(N**2) and is stable.
procedure Bubble_Sort (
Sort_Array : in out Array_Type;
Number_of_Comparisons,
Number_of_Exchanges : out Performance_Instrumentation_Type) is
Local_Comparisons,
Local_Exchanges : Performance_Instrumentation_Type := 0;
begin
-- Check for the singleton/null array cases... do nothing.
if Sort_Array'FIRST < Sort_Array'LAST then
for I in Sort_Array'FIRST .. Index_Type'VAL (Index_Type'POS (Sort_Array'LAST) - 1) loop
for J in Sort_Array'FIRST ..
Index_Type'VAL (
(Index_Type'POS (Sort_Array'LAST) +
Index_Type'POS (Sort_Array'FIRST) - 1
) -
Index_Type'POS (I)
) loop
Update_Performance_Instrumentation (Local_Comparisons);
if Sort_Array (Index_Type'SUCC (J)) < Sort_Array (J) then
Exchange_Array_Components (Sort_Array (J .. Index_Type'SUCC (J)),
Local_Exchanges);
end if;
end loop;
end loop;
end if;
Number_of_Comparisons := Local_Comparisons;
Number_of_Exchanges := Local_Exchanges;
end Bubble_Sort;
-- A bubble sort algorithm is found in the procedure below. The
-- algorithm used is a standard bubble sort with a quick exit. The
-- quick exit is taken if the data just happens to be sorted
-- in the middle of the process. Thus, this algorithm may be faster
-- than O(N**2) for arrays that are already partially ordered.
procedure Bubble_Sort_with_Quick_Exit (
Sort_Array : in out Array_Type;
Number_of_Comparisons,
Number_of_Exchanges : out Performance_Instrumentation_Type) is
Local_Comparisons,
Local_Exchanges : Performance_Instrumentation_Type := 0;
Interchange_Made : BOOLEAN;
begin
-- Check for the singleton/null array cases... do nothing.
if Sort_Array'FIRST < Sort_Array'LAST then
for I in Sort_Array'FIRST .. Index_Type'VAL (
Index_Type'POS (Sort_Array'LAST) - 1) loop
Interchange_Made := FALSE;
for J in Sort_Array'FIRST ..
Index_Type'VAL (
(Index_Type'POS (Sort_Array'LAST) +
Index_Type'POS (Sort_Array'FIRST) - 1
) -
Index_Type'POS (I)
) loop
Update_Performance_Instrumentation (Local_Comparisons);
if Sort_Array (Index_Type'SUCC (J)) < Sort_Array (J) then
Interchange_Made := TRUE;
Exchange_Array_Components (Sort_Array (J .. Index_Type'SUCC (J)),
Local_Exchanges);
end if;
end loop;
exit when not Interchange_Made;
end loop;
end if;
Number_of_Comparisons := Local_Comparisons;
Number_of_Exchanges := Local_Exchanges;
end Bubble_Sort_with_Quick_Exit;
-- A straight selection sort follows below. It is O(N**2) and
-- is instable.
procedure Selection_Sort (
Sort_Array : in out Array_Type;
Number_of_Comparisons,
Number_of_Exchanges : out Performance_Instrumentation_Type) is
Local_Comparisons,
Local_Exchanges : Performance_Instrumentation_Type := 0;
Small : Index_Type;
begin
-- Check for singelton/null array case... do nothing.
if Sort_Array'FIRST < Sort_Array'LAST then
for I in Sort_Array'FIRST .. Index_Type'PRED (Sort_Array'LAST) loop
Small := I;
for J in Index_Type'SUCC (I) .. Sort_Array'LAST loop
Update_Performance_Instrumentation (Local_Comparisons);
if Sort_Array (J) < Sort_Array (Small) then
Small := J;
end if;
end loop;
if I /= Small then
Exchange_Array_Components (Sort_Array (I .. Small),Local_Exchanges);
end if;
end loop;
end if;
Number_of_Comparisons := Local_Comparisons;
Number_of_Exchanges := Local_Exchanges;
end Selection_Sort;
-- Heapsort follows below. It is O(NlogN) and is instable.
procedure Heapsort (
Sort_Array : in out Array_Type;
Number_of_Comparisons,
Number_of_Exchanges : out Performance_Instrumentation_Type) is
Local_Comparisons,
Local_Exchanges : Performance_Instrumentation_Type := 0;
I,J : Index_Type;
Temporary_Component : Component_Type;
begin
-- Check for special array cases: do nothing on singleton/null,
-- must handle an array of 2 elements separate since the algorithm
-- assumes that Sort_Array'LENGTH >= 3.
if Sort_Array'LENGTH = 2 then
Update_Performance_Instrumentation (Local_Comparisons);
if Sort_Array (Sort_Array'LAST) < Sort_Array (Sort_Array'FIRST) then
Exchange_Array_Components (Sort_Array,Local_Exchanges);
end if;
elsif Sort_Array'FIRST < Sort_Array'LAST then
-- Create initial heap.
for K in Index_Type'SUCC (Sort_Array'FIRST) .. Sort_Array'LAST loop
-- Insert Sort_Array (K) into existing heap of size K-1.
I := K;
Temporary_Component := Sort_Array (K);
-- The complex expression in assigning to J below is necessary
-- due to the generic nature of the algorithm. This
-- expression is used in other places below too.
if Index_Type'POS (I) >= 0 then
J := Index_Type'VAL ((Index_Type'POS (I) +
Index_Type'POS (Sort_Array'FIRST) - 1) / 2);
elsif ((Index_Type'POS (I) + Index_Type'POS (Sort_Array'FIRST) - 1)
mod 2) = 0 then
J := Index_Type'VAL ((Index_Type'POS (I) +
Index_Type'POS (Sort_Array'FIRST) - 1) / 2);
else
J := Index_Type'VAL ((Index_Type'POS (I) +
Index_Type'POS (Sort_Array'FIRST) - 2) / 2);
end if;
while J >= Sort_Array'FIRST loop
Update_Performance_Instrumentation (Local_Comparisons);
exit when (Temporary_Component < Sort_Array (J)) or
Equal (Temporary_Component,Sort_Array (J));
Update_Performance_Instrumentation (Local_Exchanges);
Sort_Array (I) := Sort_Array (J);
I := J;
if Index_Type'POS (I) >= 0 then
if (((Index_Type'POS (I) + Index_Type'POS (Sort_Array'FIRST) - 1) / 2) >=
Index_Type'POS (Sort_Array'FIRST)
) and
(I /= Sort_Array'FIRST) then
J := Index_Type'VAL (
(Index_Type'POS (I) + Index_Type'POS (Sort_Array'FIRST) - 1)
/ 2);
else
exit; -- Exit while loop.
end if;
elsif ((Index_Type'POS (I) + Index_Type'POS (Sort_Array'FIRST) - 1)
mod 2) = 0 then
if (((Index_Type'POS (I) + Index_Type'POS (Sort_Array'FIRST) - 1) / 2) >=
Index_Type'POS (Sort_Array'FIRST)
) and
(I /= Sort_Array'FIRST) then
J := Index_Type'VAL (
(Index_Type'POS (I) + Index_Type'POS (Sort_Array'FIRST) - 1)
/ 2);
else
exit; -- Exit while loop.
end if;
elsif (((Index_Type'POS (I) + Index_Type'POS (Sort_Array'FIRST) - 1) / 2) >=
Index_Type'POS (Sort_Array'FIRST)
) and
(I /= Sort_Array'FIRST) then
J := Index_Type'VAL (
(Index_Type'POS (I) + Index_Type'POS (Sort_Array'FIRST) - 2)
/ 2);
else
exit; -- Exit while loop.
end if;
end loop; -- End of while loop.
Update_Performance_Instrumentation (Local_Comparisons);
if not Equal (Temporary_Component,Sort_Array (I)) then
Update_Performance_Instrumentation (Local_Exchanges);
Sort_Array (I) := Temporary_Component;
end if;
end loop; -- End of for loop.
-- We remove Sort_Array (Sort_Array'FIRST) and place it in its
-- proper position in the array. We then adjust the heap.
for K in reverse Index_Type'SUCC (Sort_Array'FIRST) .. Sort_Array'LAST loop
Update_Performance_Instrumentation (Local_Exchanges);
Temporary_Component := Sort_Array (K);
Sort_Array (K) := Sort_Array (Sort_Array'FIRST);
-- Readjust the heap of order K-1. Move Temporary_Component down the
-- heap for proper position.
I := Sort_Array'FIRST;
J := Index_Type'SUCC (I);
-- The following if statement can be described as follows:
-- if (Sort_Array (Element#2) < Sort_Array (Element#3)) and
-- (Position of K's predecessor >= Position of Element#3) then
-- J := Position of Element#3;
-- end if;
-- The complications are due to the generic nature of the
-- algorithm.
Update_Performance_Instrumentation (Local_Comparisons);
if ((Sort_Array (Index_Type'SUCC (Sort_Array'FIRST))) <
(Sort_Array (Index_Type'SUCC (Index_Type'SUCC (Sort_Array'FIRST))))
) and
(Index_Type'PRED (K) >=
Index_Type'SUCC (Index_Type'SUCC (Sort_Array'FIRST))
) then
J := Index_Type'SUCC (Index_Type'SUCC (Sort_Array'FIRST));
end if;
-- J is the larger son of I in the heap of size K-1.
while J <= Index_Type'PRED (K) loop
Update_Performance_Instrumentation (Local_Comparisons);
if (Sort_Array (J) < Temporary_Component) or
Equal (Sort_Array (J),Temporary_Component) then
exit; -- exit while loop
end if;
Update_Performance_Instrumentation (Local_Exchanges);
Sort_Array (I) := Sort_Array (J);
I := J;
if (((Index_Type'POS (I) * 2) - Index_Type'POS (Sort_Array'FIRST) + 1) <=
Index_Type'POS (Index_Type'PRED (Sort_Array'LAST))
) and
(((Index_Type'POS (I) * 2) - Index_Type'POS (Sort_Array'FIRST) + 1) >=
Index_Type'POS (Sort_Array'FIRST)
) then
J := Index_Type'VAL (
(Index_Type'POS (I) * 2) - Index_Type'POS (Sort_Array'FIRST) + 1);
else
exit; -- Exit while loop.
end if;
if Index_Type'SUCC (J) <= Index_Type'PRED (K) then
Update_Performance_Instrumentation (Local_Comparisons);
if Sort_Array (J) < Sort_Array (Index_Type'SUCC (J)) then
J := Index_Type'SUCC (J);
end if;
end if;
end loop; -- End of while loop.
Update_Performance_Instrumentation (Local_Exchanges);
Sort_Array (I) := Temporary_Component;
end loop; -- End of for loop.
end if;
Number_of_Comparisons := Local_Comparisons;
Number_of_Exchanges := Local_Exchanges;
end Heapsort;
-- Simple insertion sort follows below. It is O(N**2), but usually
-- better than a bubble sort.
procedure Insertion_Sort (
Sort_Array : in out Array_Type;
Number_of_Comparisons,
Number_of_Exchanges : out Performance_Instrumentation_Type) is
Local_Comparisons,
Local_Exchanges : Performance_Instrumentation_Type := 0;
I : Index_Type;
Temporary_Component : Component_Type;
Found : BOOLEAN;
begin
-- Handle special cases of singleton/null arrays...
-- do nothing.
if Sort_Array'FIRST < Sort_Array'LAST then
-- Initially Sort_Array (Sort_Array'FIRST) may be thought of
-- as a sorted file of one element. After each repetition of
-- the following loop, the elements Sort_Array (Sort_Array'FIRST)
-- through Sort_Array (K) are in order.
for K in Index_Type'SUCC (Sort_Array'FIRST) .. Sort_Array'LAST loop
-- insert Sort_Array (K) into the sorted file
Temporary_Component := Sort_Array (K);
-- Move down one position all elements "greater" than
-- Temporary_Component
I := Index_Type'PRED (K);
Found := FALSE;
while (not Found) loop
Update_Performance_Instrumentation (Local_Comparisons);
if Temporary_Component < Sort_Array (I) then
Update_Performance_Instrumentation (Local_Exchanges);
Sort_Array (Index_Type'SUCC (I)) := Sort_Array (I);
if I /= Sort_Array'FIRST then
I := Index_Type'PRED (I);
else
exit; -- Exit while loop.
end if;
else
Found := TRUE;
end if;
end loop; -- End of while loop.
-- Insert Temporary_Component at proper position.
Update_Performance_Instrumentation (Local_Exchanges);
if Found then
Sort_Array (Index_Type'SUCC (I)) := Temporary_Component;
else
Sort_Array (Sort_Array'FIRST) := Temporary_Component;
end if;
end loop; -- End of for loop.
end if;
Number_of_Comparisons := Local_Comparisons;
Number_of_Exchanges := Local_Exchanges;
end Insertion_Sort;
-- The straight merge sort procedure below is O(NlogN) and is instable.
procedure Merge_Sort (
Sort_Array : in out Array_Type;
Number_of_Comparisons,
Number_of_Exchanges : out Performance_Instrumentation_Type) is
Auxiliary_Array : Array_Type (Sort_Array'FIRST .. Sort_Array'LAST);
Lower_Bound1,
Lower_Bound2,
Upper_Bound1,
Upper_Bound2,
Auxiliary_Index,
I, J : Index_Type;
I_Overflow,
J_Overflow,
Aux_Overflow : BOOLEAN;
Size : POSITIVE := 1; -- Merge files of size 1.
Local_Comparisons,
Local_Exchanges : Performance_Instrumentation_Type := 0;
begin
while Size < Sort_Array'LENGTH loop
Lower_Bound1 := Sort_Array'FIRST;
Auxiliary_Index := Auxiliary_Array'FIRST;
-- Check if there are two files to merge.
while (Index_Type'POS (Lower_Bound1) + Size) <=
Index_Type'POS (Sort_Array'LAST) loop
I_Overflow := FALSE;
J_Overflow := FALSE;
Aux_Overflow := FALSE;
-- Compute remaining indices.
Lower_Bound2 := Index_Type'VAL (Index_Type'POS (Lower_Bound1) +
Size);
Upper_Bound1 := Index_Type'PRED (Lower_Bound2);
if Index_Type'POS (Lower_Bound2) + Size - 1 >
Index_Type'POS (Sort_Array'LAST) then
Upper_Bound2 := Sort_Array'LAST;
else
Upper_Bound2 := Index_Type'VAL (Index_Type'POS (Lower_Bound2) +
Size - 1);
end if;
-- Proceed through the two subfiles.
I := Lower_Bound1;
J := Lower_Bound2;
while (I <= Upper_Bound1) and (J <= Upper_Bound2) loop
-- Enter smaller into Auxiliary_Array.
Update_Performance_Instrumentation (Local_Comparisons);
Update_Performance_Instrumentation (Local_Exchanges);
if (Sort_Array (I) < Sort_Array (J)) or
Equal (Sort_Array (I),Sort_Array (J)) then
Auxiliary_Array (Auxiliary_Index) := Sort_Array (I);
if Auxiliary_Index /= Auxiliary_Array'LAST then
Auxiliary_Index := Index_Type'SUCC (Auxiliary_Index);
else
Aux_Overflow := TRUE;
end if;
if I /= Sort_Array'LAST then
I := Index_Type'SUCC (I);
else
I_Overflow := TRUE;
exit;
end if;
else
Auxiliary_Array (Auxiliary_Index) := Sort_Array (J);
if Auxiliary_Index /= Auxiliary_Array'LAST then
Auxiliary_Index := Index_Type'SUCC (Auxiliary_Index);
else
Aux_Overflow := TRUE;
end if;
if J /= Sort_Array'LAST then
J := Index_Type'SUCC (J);
else
J_Overflow := TRUE;
exit;
end if;
end if;
end loop; -- While loop.
-- At this point one of the subfiles has been exhausted.
-- Insert any remaining portions of the other file.
while (not I_Overflow) and (I <= Upper_Bound1) loop
Update_Performance_Instrumentation (Local_Exchanges);
Auxiliary_Array (Auxiliary_Index) := Sort_Array (I);
if I /= Sort_Array'LAST then
I := Index_Type'SUCC (I);
else
I_Overflow := TRUE;
end if;
if Auxiliary_Index /= Auxiliary_Array'LAST then
Auxiliary_Index := Index_Type'SUCC (Auxiliary_Index);
else
Aux_Overflow := TRUE;
end if;
end loop;
while (not J_Overflow) and (J <= Upper_Bound2) loop
Update_Performance_Instrumentation (Local_Exchanges);
Auxiliary_Array (Auxiliary_Index) := Sort_Array (J);
if J /= Sort_Array'LAST then
J := Index_Type'SUCC (J);
else
J_Overflow := TRUE;
end if;
if Auxiliary_Index /= Auxiliary_Array'LAST then
Auxiliary_Index := Index_Type'SUCC (Auxiliary_Index);
else
Aux_Overflow := TRUE;
end if;
end loop;
-- Advance Lower_Bound1 to start of next pair of files.
if Index_Type'POS (Upper_Bound2) + 1 <=
Index_Type'POS (Sort_Array'LAST) then
Lower_Bound1 := Index_Type'SUCC (Upper_Bound2);
else
Lower_Bound1 := Sort_Array'LAST;
end if;
end loop; -- While loop.
-- Copy any remaining single file.
I := Lower_Bound1;
while not Aux_Overflow loop
Update_Performance_Instrumentation (Local_Exchanges);
Auxiliary_Array (Auxiliary_Index) := Sort_Array (I);
if Auxiliary_Index /= Auxiliary_Array'LAST then
Auxiliary_Index := Index_Type'SUCC (Auxiliary_Index);
else
Aux_Overflow := TRUE;
end if;
if I /= Sort_Array'LAST then
I := Index_Type'SUCC (I);
else
I_Overflow := TRUE;
end if;
end loop;
-- Adjust Sort_Array and Size.
Sort_Array := Auxiliary_Array;
Size := Size * 2;
end loop; -- While loop.
Number_of_Comparisons := Local_Comparisons;
Number_of_Exchanges := Local_Exchanges;
end Merge_Sort;
procedure Sort (
Sort_Array : in out Array_Type;
Number_of_Comparisons,
Number_of_Exchanges : out Performance_Instrumentation_Type;
Sort_Algorithm : in Sort_Algorithm_Type := Quicksort) is
begin
-- Call the right sorting algorithm.
case Sort_Algorithm is
when Quicksort =>
Quicksort (Sort_Array,Number_of_Comparisons,Number_of_Exchanges);
when Recursive_Quicksort =>
Recursive_Quicksort (Sort_Array,Number_of_Comparisons,Number_of_Exchanges);
when Bsort =>
Bsort (Sort_Array,Number_of_Comparisons,Number_of_Exchanges);
when Bubble_Sort =>
Bubble_Sort (Sort_Array,Number_of_Comparisons,Number_of_Exchanges);
when Bubble_Sort_with_Quick_Exit =>
Bubble_Sort_with_Quick_Exit (Sort_Array,Number_of_Comparisons,Number_of_Exchanges);
when Selection_Sort =>
Selection_Sort (Sort_Array,Number_of_Comparisons,Number_of_Exchanges);
when Heapsort =>
Heapsort (Sort_Array,Number_of_Comparisons,Number_of_Exchanges);
when Insertion_Sort =>
Insertion_Sort (Sort_Array,Number_of_Comparisons,Number_of_Exchanges);
when Merge_Sort =>
Merge_Sort (Sort_Array,Number_of_Comparisons,Number_of_Exchanges);
end case;
end Sort;
-- Overloading of procedure Sort that does not return instrumentation
-- analysis data follows below.
procedure Sort (
Sort_Array : in out Array_Type;
Sort_Algorithm : in Sort_Algorithm_Type := Quicksort) is
Dummy_Comparisons,
Dummy_Exchanges : Performance_Instrumentation_Type;
begin
Sort (Sort_Array,Dummy_Comparisons,Dummy_Exchanges,Sort_Algorithm);
end Sort;
-- Overloading of procedure Sort used to preserve original data and to
-- return instrumentation analysis results follows below.
procedure Sort (
Unsorted_Array : in Array_Type;
Sorted_Array : out Array_Type;
Number_of_Comparisons,
Number_of_Exchanges : out Performance_Instrumentation_Type;
Sort_Algorithm : in Sort_Algorithm_Type := Quicksort) is
Local_Array : Array_Type (Unsorted_Array'RANGE) := Unsorted_Array;
begin
Number_of_Comparisons := 0;
Number_of_Exchanges := 0;
-- Check for equal length of both arrays.
if Unsorted_Array'LENGTH /= Sorted_Array'LENGTH then
raise Sort_Arrays_Length_Mismatch;
end if;
Sort (Local_Array,Number_of_Comparisons,Number_of_Exchanges,
Sort_Algorithm);
Sorted_Array := Local_Array;
end Sort;
-- Overloading of procedure Sort used to preserve the original data
-- follows below.
procedure Sort (
Unsorted_Array : in Array_Type;
Sorted_Array : out Array_Type;
Sort_Algorithm : in Sort_Algorithm_Type := Quicksort) is
Local_Array : Array_Type (Unsorted_Array'RANGE) := Unsorted_Array;
Dummy_Comparisons,
Dummy_Exchanges : Performance_Instrumentation_Type;
begin
-- Check for equal length of both arrays.
if Unsorted_Array'LENGTH /= Sorted_Array'LENGTH then
raise Sort_Arrays_Length_Mismatch;
end if;
Sort (Local_Array,Dummy_Comparisons,Dummy_Exchanges,Sort_Algorithm);
Sorted_Array := Local_Array;
end Sort;
-- Overloading of function Sort used in inline expressions follows below.
function Sort (
Sort_Array : in Array_Type;
Sort_Algorithm : in Sort_Algorithm_Type := Quicksort)
return Array_Type is
Sorted_Array : Array_Type (Sort_Array'RANGE) := Sort_Array;
Dummy_Comparisons,
Dummy_Exchanges : Performance_Instrumentation_Type;
begin
Sort (Sorted_Array,Dummy_Comparisons,Dummy_Exchanges,Sort_Algorithm);
return Sorted_Array;
end Sort;
end Sort_Utilities;
